home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d12 / v9n21.arc / DGSTR.PAS < prev    next >
Pascal/Delphi Source File  |  1990-11-17  |  29KB  |  912 lines

  1. {
  2.  ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
  3.  █                                                                         █
  4.  █        TITLE :      DGSTR.TPU                                           █
  5.  █      PURPOSE :      Basic string-handling routines.                     █
  6.  █       AUTHOR :      David Gerrold, CompuServe ID:  70307,544            █
  7.  █  _____________________________________________________________________  █
  8.  █                                                                         █
  9.  █   Written in Turbo Pascal, Version 5.5,                                 █
  10.  █   with routines from TurboPower, Object Professional.                   █
  11.  █                                                                         █
  12.  █   Turbo Pascal is a product of Borland International.                   █
  13.  █   Object Professional is a product of TurboPower Software.              █
  14.  █  _____________________________________________________________________  █
  15.  █                                                                         █
  16.  █   This is not public domain software.                                   █
  17.  █   This software is copyright 1990, by David Gerrold.                    █
  18.  █   Permission is hereby granted for personal use.                        █
  19.  █                                                                         █
  20.  █        The Brass Cannon Corporation                                     █
  21.  █        9420 Reseda Blvd., #804                                          █
  22.  █        Northridge, CA  91324-2932.                                      █
  23.  █                                                                         █
  24.  ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
  25.                                                                             }
  26. { Compiler Directives ===================================================== }
  27.  
  28. {$A-}    {Switch word alignment off, necessary for cloning}
  29. {$R-}    {Range checking off}
  30. {$B-}    {Boolean complete evaluation off}
  31. {$S-}    {Stack checking off}
  32. {$I-}    {I/O checking off}
  33. {$N+,E+} {Simulate numeric coprocessor}
  34. {$M 16384,0,327680} {stack and heap}
  35. {$V-}    {Variable range checking off}
  36.  
  37. { Name ==================================================================== }
  38.  
  39. UNIT DgStr;
  40. {
  41.   The purpose of this code is to provide basic string-handling routines.
  42. }
  43.  
  44. { Interface =============================================================== }
  45.  
  46. INTERFACE
  47.  
  48. USES
  49. { Object Professional Units }
  50.   OpString,
  51.  
  52. { Dg Units }
  53.   DgCh;
  54.  
  55. { Declarations ============================================================ }
  56.  
  57. TYPE
  58.   StringPtr  = ^string;
  59.   String2    = string [2];
  60.   String3    = string [3];
  61.   String6    = string [6];
  62.   String8    = string [8];
  63.   String12   = string [12];
  64.   String15   = string [15];
  65.   String25   = string [25];
  66.   String80   = string [80];
  67.  
  68. { Functions and Procedure Declarations ==================================== }
  69. { Position functions ------------------------------------------------------ }
  70.  
  71. FUNCTION LastPos (SubStr, S : string) : byte;
  72. { Pos function that works from right to left, returns last pos of substr. }
  73.  
  74. { Strip and Pad functions ------------------------------------------------- }
  75.  
  76. FUNCTION Strip (S : string;  Ch : char) : string;
  77. { Strips every occurrence of Ch from S. }
  78.  
  79. FUNCTION TrimLeadCh (S : string;  Ch : char) : string;
  80. { Trims all occurrences of Ch from the beginning of string S. }
  81.  
  82. FUNCTION TrimTrailCh (S : string;  Ch : char) : string;
  83. { Trims all occurrences of Ch from the end of string S. }
  84.  
  85. FUNCTION TrimCh (S : string;  Ch : char) : string;
  86. { Trims all occurrences of Ch from the beginning and end of string S. }
  87.  
  88. FUNCTION TrimThe (S : string) : string;
  89. { Removes 'A', 'An', and 'The' from the beginning of string S. }
  90.  
  91. FUNCTION PadCenter (S : string;  Width : byte) : string;
  92. { Pads S with spaces on both sides to produce a centered string. }
  93.  
  94. FUNCTION SpaceFix (S : string) : string;
  95. { Loops through S, corrects spacing between words. }
  96.  
  97. { Capitalization functions ------------------------------------------------ }
  98.  
  99. FUNCTION CapFirst (S : string) : string;
  100. { Capitalizes the first letter in the string. }
  101.  
  102. FUNCTION CapWords (S : string) : string;
  103. { Capitalizes first letter of every word in the string. }
  104.  
  105. { Translation functions --------------------------------------------------- }
  106.  
  107. PROCEDURE OverWrite (VAR S : string;  SubStr : string;  Position : byte);
  108. { Replaces text in S at Position with text in SubStr. }
  109.  
  110. PROCEDURE Replace (VAR S : string;  OldStr, NewStr : string);
  111. { Finds OldStr in S and replaces it with NewStr. }
  112.  
  113. PROCEDURE ReplaceAll (VAR S : string;  OldStr, NewStr : string);
  114. { Replaces all occurrences of OldStr with NewStr. }
  115.  
  116. PROCEDURE Translate (VAR S : string;  OldCh, NewCh : char);
  117. { Translates every occurrence of OldCh into NewCh. }
  118.  
  119. FUNCTION TranslateRaw (S : string) : string;
  120. { Translates code into strings:  ^E becomes ctrl char,
  121.   #39 becomes apostrophe, etc. }
  122.  
  123. { Number functions -------------------------------------------------------- }
  124.  
  125. FUNCTION Num2Str (Num : float) : string;
  126. { Returns a number in shortest possible string. }
  127.  
  128. FUNCTION ContainsNumber (S : string) : boolean;
  129. { Returns true if S contains any digits. }
  130.  
  131. { Extraction functions ---------------------------------------------------- }
  132.  
  133. FUNCTION GetSubStr (S : string; Pos1, Pos2 : byte) : string;
  134. { Extracts a SubString, starting at Pos1, ending at Pos2. }
  135.  
  136. FUNCTION ExtractFirstWord (VAR S : string) : string;
  137. { Returns first word in string, deletes it from source. }
  138.  
  139. FUNCTION ExtractFirstNumber (VAR S : string) : word;
  140. { Returns first number in string, or zero on failure. }
  141.  
  142. FUNCTION ExtractFirstExtended (S : string) : extended;
  143. { Returns first number in string, or zero on failure. }
  144.  
  145. { String Formatting functions --------------------------------------------- }
  146.  
  147. FUNCTION Justify (S : string80;  W : byte) : string80;
  148. { returns a string padded internally to length W }
  149.  
  150. { Hashing functions ------------------------------------------------------- }
  151.  
  152. FUNCTION MultiSoundex (S : string) : string;
  153. { Returns multiple soundex string for multiple words. }
  154.  
  155. FUNCTION Compress (S : string) : string;
  156. { Compresses text string at a ratio of 8:5. }
  157.  
  158. FUNCTION Decompress (S : string) : string;
  159. { Decompresses text string at a ratio of 5:8. }
  160.  
  161. FUNCTION HashVal (S : String) : extended;
  162. { Returns a hash value based on the first 10 characters of the string. }
  163.  
  164. { ========================================================================= }
  165. { Implementation ========================================================== }
  166.  
  167. IMPLEMENTATION
  168.  
  169. { ========================================================================= }
  170. { LastPos ================================================================= }
  171.  
  172. FUNCTION LastPos (SubStr, S : string) : byte;
  173. { Pos function that works from right to left, returns last pos of substr. }
  174.  
  175. VAR
  176.   Loop : byte;
  177.   Len  : byte absolute S;
  178.   SLen : byte absolute SubStr;
  179.  
  180. BEGIN
  181.   Loop := succ (Len - SLen);
  182.   While
  183.     (Loop > 0)
  184.       and
  185.     (Copy (S, Loop, SLen) <> SubStr)
  186.   do
  187.     dec (Loop);
  188.   LastPos := Loop;
  189. END;
  190.  
  191. { ========================================================================= }
  192. { Strip =================================================================== }
  193.  
  194. FUNCTION Strip (S : string;  Ch : char) : string;
  195. { Strips every occurrence of Ch from S. }
  196.  
  197. VAR
  198.   Len  : byte absolute S;
  199.   Loop : byte;
  200.  
  201. BEGIN
  202.   S := TrimCh (S, Ch);
  203.   For Loop := Len downto 1 do                    { step backward }
  204.     If S [Loop] = Ch then begin
  205.       move (S [succ (Loop)], S [Loop], Len - Loop);
  206.       dec (Len);
  207.       end;
  208.   Strip := S;
  209. END;
  210.  
  211. { TrimLeadCh ============================================================== }
  212.  
  213. FUNCTION TrimLeadCh (S : string;  Ch : char) : string;
  214. { Trims all occurrences of Ch from the beginning of string S. }
  215.  
  216. VAR
  217.   Len  : byte absolute S;
  218.  
  219. BEGIN
  220.   While
  221.     (S [1] = Ch) and (Len > 0)                   { while S [1] = Ch }
  222.   do begin
  223.     dec (Len);                                   { shorten S }
  224.     move (S [2], S [1], Len);                    { delete 1st char }
  225.     end;
  226.   TrimLeadCh := S;                               { return }
  227. END;
  228.  
  229. { TrimTrailCh ============================================================= }
  230.  
  231. FUNCTION TrimTrailCh (S : string;  Ch : char) : string;
  232. { Trims all occurrences of Ch from the end of string S. }
  233.  
  234. VAR
  235.   Len  : byte absolute S;
  236.  
  237. BEGIN
  238.   While
  239.     (S [Len] = Ch)                               { while last char = Ch }
  240.   do
  241.     dec (Len);                                   { shorten S }
  242.   TrimTrailCh := S;                              { return }
  243. END;
  244.  
  245. { TrimCh ================================================================== }
  246.  
  247. FUNCTION TrimCh (S : string;  Ch : char) : string;
  248. { Trims all occurrences of Ch from the beginning and end of string S. }
  249.  
  250. BEGIN
  251.   TrimCh := TrimTrailCh (TrimLeadCh (S, Ch), Ch);
  252. END;
  253.  
  254. { TrimThe ================================================================= }
  255.  
  256. FUNCTION TrimThe (S : string) : string;
  257. { Removes 'A', 'An', and 'The' from the beginning of string S. }
  258.  
  259. BEGIN
  260.   if CompUCString ('A ', Copy (S, 1, 2)) = Equal then
  261.     delete (S, 1, 2)
  262.   else
  263.     if CompUCString ('AN ', Copy (S, 1, 3)) = Equal then
  264.       delete (S, 1, 3)
  265.     else
  266.       if CompUCString ('THE ', Copy (S, 1, 4)) = Equal then
  267.         delete (S, 1, 4);
  268.   TrimThe := S;
  269. END;
  270.  
  271. { PadCenter =============================================================== }
  272.  
  273. FUNCTION PadCenter (S : string;  Width : byte) : string;
  274. { Pads S with spaces on both sides to produce a centered string. }
  275.  
  276. VAR
  277.   Len  : byte absolute S;
  278.  
  279. BEGIN
  280.   PadCenter := Pad (LeftPad (S, Len + (Width - Len) div 2), Width);
  281. END;
  282.  
  283. { SpaceFix ================================================================ }
  284.  
  285. FUNCTION SpaceFix (S : string) : string;
  286. { Loops through S, corrects spacing between words. }
  287. VAR
  288.   Loop : byte;
  289.   Len  : byte absolute S;
  290.   SpaceFlag : boolean;
  291.  
  292. BEGIN
  293.   Loop := Len;
  294.   SpaceFlag := In2SpacePunctuation (S [Len]);
  295.   repeat
  296.     dec (Loop);
  297.     if S [Loop] = ' ' then begin
  298.       if SpaceFlag then delete (S, Loop, 1);
  299.       SpaceFlag := true;
  300.       end
  301.     else begin
  302.       if SpaceFlag and In2SpacePunctuation (S [Loop]) then
  303.         insert (' ', S, succ (Loop));
  304.       SpaceFlag := false;
  305.       end;
  306.   until
  307.     Loop = 1;
  308.  
  309.   ReplaceAll (S, 'Dr.  ',  'Dr. ');              { save honorifics }
  310.   ReplaceAll (S, 'Mr.  ',  'Mr. ');
  311.   ReplaceAll (S, 'Mrs.  ', 'Mrs. ');
  312.   ReplaceAll (S, 'Ms.  ',  'Ms. ');
  313.   ReplaceAll (S, 'St.  ',  'St. ');
  314.  
  315.   SpaceFix := S;
  316. END;
  317.  
  318. { ========================================================================= }
  319. { CapFirst ---------------------------------------------------------------- }
  320.  
  321. FUNCTION CapFirst (S : string) : string;
  322. { Capitalizes the first letter in the string. }
  323.  
  324. BEGIN
  325.   S := StLoCase (S);                             { lower case string }
  326.   S [1] := UpCaseMac (S [1]);                    { upper case first letter }
  327.   CapFirst := S;                                 { return }
  328. END;
  329.  
  330. { CapWords ================================================================ }
  331.  
  332. FUNCTION CapWords (S : string) : string;
  333. { Capitalizes first letter of every word in the string. }
  334.  
  335. VAR
  336.   Loop : byte;
  337.   Len  : byte absolute S;
  338.  
  339. BEGIN
  340.   S := StLoCase (S);                             { lower case string }
  341.   S [1] := UpCaseMac (S [1]);                    { Cap first letter }
  342.   For Loop := 2 to Len do
  343.     If (S [Loop] <> ' ') and (S [pred (Loop)] = ' ') then
  344.       S [Loop] := UpCaseMac (S [Loop]);
  345.   CapWords := S;
  346. END;
  347.  
  348. { ========================================================================= }
  349. { OverWrite =============================================================== }
  350.  
  351. PROCEDURE OverWrite (VAR S : string;  SubStr : string;  Position : byte);
  352. {
  353.   Replaces text in S at Position with text in SubStr.
  354.  
  355.   Although it would be faster to use 'move (OverStr, S, OverStrLen)',
  356.   that method does not correctly manage the length of S.  In specific,
  357.   using move does not allow S to concatenate extra chars if OverStr
  358.   goes beyond its length, nor will move manage the automatic truncation
  359.   of S if it grows beyond 255 chars.
  360. }
  361.  
  362. VAR
  363.   SLen : byte absolute SubStr;
  364.  
  365. BEGIN
  366.   delete (S, Position, SLen);                    { delete current text }
  367.   insert (SubStr, S, Position);                  { insert new text }
  368. END;
  369.  
  370. { Replace ================================================================= }
  371.  
  372. PROCEDURE Replace (VAR S : string;  OldStr, NewStr : string);
  373. { Finds OldStr in S and replaces it with NewStr. }
  374.  
  375. VAR
  376.   Position  : byte;
  377.   OldStrLen : byte absolute OldStr;
  378.  
  379. BEGIN
  380.   Position := Pos (StUpCase (OldStr), StUpCase (S));  { find OldStr }
  381.   If Position > 0 then begin                          { if OldStr exists }
  382.     delete (S, Position, OldStrLen);                  { delete it }
  383.     insert (NewStr, S, Position);                     { insert NewStr }
  384.     end;
  385. END;
  386.  
  387. { ReplaceAll ============================================================== }
  388.  
  389. PROCEDURE ReplaceAll (VAR S : string;  OldStr, NewStr : string);
  390. { Replaces all occurrences of OldStr with NewStr. }
  391.  
  392. VAR
  393.   Position  : byte;
  394.   OldStrLen : byte absolute OldStr;
  395.  
  396. BEGIN
  397.   Repeat
  398.     Position := Pos (StUpCase (OldStr), StUpCase (S));  { find OldStr }
  399.     If Position > 0 then begin                          { if OldStr exists }
  400.       delete (S, Position, OldStrLen);                  { delete it }
  401.       insert (NewStr, S, Position);                     { insert NewStr }
  402.       end;
  403.   until
  404.     Position = 0;
  405. END;
  406.  
  407. { Translate =============================================================== }
  408.  
  409. PROCEDURE Translate (VAR S : string;  OldCh, NewCh : char);
  410. { Translates every occurrence of OldCh into NewCh. }
  411.  
  412. VAR
  413.   Len  : byte absolute S;
  414.   Loop : byte;
  415.  
  416. BEGIN
  417.   If OldCh <> NewCh then
  418.     For Loop := 1 to Len do
  419.       If S [Loop] = OldCh then
  420.         S [Loop] := NewCh;
  421. END;
  422.  
  423. { TranslateRaw ============================================================ }
  424.  
  425. FUNCTION TranslateRaw (S : string) : string;
  426. {
  427.   Translates code into strings.
  428.  
  429.   ^E becomes actual ctrl character.
  430.   #39 becomes char (39).
  431.   Text between apostrophes remains unchanged.
  432.  
  433.   Useful for translating variable strings from text files.  No
  434.   error-trapping here.  Routine tends to ignore what it doesn't
  435.   understand.  Use with caution.  Make sure input strings are
  436.   valid or results may be unpredictable.
  437. }
  438.  
  439. VAR
  440.   Temp   : string;
  441.   Len    : byte absolute S;
  442.   Loop   : byte;
  443.   NumStr : string3;
  444.   W      : word;
  445.   Ch     : char;
  446.   Flag   : boolean;                              { read chars between '' }
  447.  
  448. BEGIN
  449.   Loop := 1;
  450.   Temp := '';
  451.   Flag := false;
  452.  
  453.   While
  454.     Loop <= Len
  455.   do begin
  456.     if
  457.       Flag and (S [Loop] <> #39)
  458.     then
  459.       Temp := Temp + S [Loop]
  460.     else
  461.       Case S [Loop] of
  462.         '^' : begin                              { Control Character }
  463.               inc (Loop);
  464.               Ch := Chr (Ord (UpCaseMac (S [Loop])) - 64);
  465.               If (Ch >= #0) and (Ch < #32) then Temp := Temp + Ch;
  466.               end;
  467.         '#' : begin                              { Decimal Character }
  468.               inc (Loop);
  469.               NumStr := '';
  470.               While
  471.                 (S [Loop] >= '0')
  472.                   and (S [Loop] <= '9')
  473.                     and (Loop <= Len)
  474.               do begin
  475.                 NumStr := NumStr + S [Loop];
  476.                 Inc (Loop);
  477.                 end;
  478.               dec (Loop);
  479.               If Str2Word (NumStr, W) then
  480.                 Temp := Temp + Chr (W);
  481.               end;
  482.         #39 : if
  483.                 Flag and (Loop < pred (Len)) and (S [succ (Loop)] = #39)
  484.               then begin
  485.                 inc (Loop);
  486.                 Temp := Temp + S [Loop];
  487.                 end
  488.               else
  489.                 Flag := not Flag;
  490.         end; { Case }
  491.     inc (Loop);
  492.     end;
  493.   TranslateRaw := Temp;
  494. END;
  495.  
  496. { ========================================================================= }
  497. { Num2Str ================================================================= }
  498.  
  499. FUNCTION Num2Str (Num : float) : string;
  500. { Returns a number in shortest possible string. }
  501.  
  502. VAR
  503.   S        : string;
  504.   Len      : byte absolute S;
  505.   ExpStr   : string [4];
  506.   EPos,
  507.   E        : word;
  508.  
  509. BEGIN
  510.   Num2Str := '0';
  511.   if Num = 0 then exit;
  512.  
  513.   If (abs (Num) > 1E+10) or (abs (Num) < 1E-10) then begin
  514.     S := Trim (Real2Str (Num, 25, -1));
  515.     EPos   := Pos ('E', S);                      { where is 'E' ? }
  516.     ExpStr := GetSubStr (S, EPos + 2, Len);
  517.     S := TrimTrailCh (
  518.            TrimTrailCh (
  519.              GetSubStr (S, 1, pred (Epos)),
  520.            '0'),
  521.          '.') +
  522.          GetSubStr (S, EPos, Succ (EPos)) +    { is E + or - ? }
  523.          TrimLeadCh (GetSubStr (S, EPos + 2, Len), '0');
  524.     end
  525.   else
  526.     S := TrimTrailCh (
  527.            TrimTrailCh (
  528.              Trim (
  529.                Real2Str (Num, 35, 18)
  530.              ),
  531.            '0'),
  532.          '.');
  533.  
  534.   Num2Str := S;
  535. END;
  536.  
  537. { ContainsNumber ========================================================== }
  538.  
  539. FUNCTION ContainsNumber (S : string) : boolean;
  540. { Returns true if S contains any digits. }
  541.  
  542. VAR
  543.   Len  : byte absolute S;
  544.   Flag : boolean;
  545.   Loop : byte;
  546.  
  547. BEGIN
  548.   Flag := false;
  549.   If Len > 0 then begin
  550.     Loop := 1;
  551.     Repeat
  552.       Flag := InNumbers (S [Loop]);
  553.       inc (Loop);
  554.     Until
  555.       Flag or (Loop > Len);
  556.     end;
  557.   ContainsNumber := Flag;
  558. END;
  559.  
  560. { ========================================================================= }
  561. { GetSubStr =============================================================== }
  562.  
  563. FUNCTION GetSubStr (S : string; Pos1, Pos2 : byte) : string;
  564. { Extracts a SubString, starting at Pos1, ending at Pos2. }
  565.  
  566. BEGIN
  567.   GetSubStr := Copy (S, Pos1, succ (Pos2) - Pos1);
  568. END;
  569.  
  570. { ExtractFirstWord ======================================================== }
  571.  
  572. FUNCTION ExtractFirstWord (VAR S : string) : string;
  573. { Returns first word in string, deletes it from source. }
  574.  
  575. VAR
  576.   Loop : byte;
  577.   Len  : byte absolute S;
  578.  
  579. BEGIN
  580.   ExtractFirstWord := '';
  581.  
  582.   Loop := 0;
  583.   repeat                                         { look for start of word }
  584.     inc (Loop)
  585.   until
  586.     (Loop > Len)
  587.       or
  588.     InAlphabet (S [Loop]);
  589.   delete (S, 1, pred (Loop));
  590.  
  591.   Loop := 0;
  592.   repeat                                         { look for end of word }
  593.     inc (Loop)
  594.   until
  595.     (Loop > Len)
  596.       or
  597.     not InAlphabet (S [Loop]);
  598.   dec (Loop);
  599.  
  600.   if Loop > 0 then begin
  601.     ExtractFirstWord := GetSubStr (S, 1, Loop);
  602.     Delete (S, 1, Loop);
  603.     end;
  604.   S := Trim (S);
  605. END;
  606.  
  607. { ExtractFirstNumber ====================================================== }
  608.  
  609. FUNCTION ExtractFirstNumber (VAR S : string) : word;
  610. {
  611.   Returns first number in string, or zero on failure.
  612.   Deletes first number, if found.
  613. }
  614.  
  615. VAR
  616.   Len  : byte absolute S;
  617.   Loop : byte;
  618.   N    : word;
  619.  
  620. BEGIN
  621.   ExtractFirstNumber := 0;
  622.   If not ContainsNumber (S) then exit;
  623.  
  624.   Loop := 0;
  625.   repeat                                         { look for start of word }
  626.     inc (Loop)
  627.   until
  628.     (Loop > Len)
  629.       or
  630.     InNumbers (S [Loop])
  631.       or
  632.     (S [Loop] = '-');
  633.   delete (S, 1, pred (Loop));
  634.  
  635.   Loop := 0;
  636.   repeat                                         { look for end of word }
  637.     inc (Loop)
  638.   until
  639.     (Loop > Len)
  640.       or
  641.     not InNumbers (S [Loop]);
  642.   dec (Loop);
  643.  
  644.   if Loop > 0 then
  645.     if Str2Word (GetSubStr (S, 1, Loop), N) then begin
  646.       ExtractFirstNumber := N;
  647.       delete (S, 1, Loop);
  648.       end;
  649. END;
  650.  
  651. { ExtractFirstExtended ==================================================== }
  652.  
  653. FUNCTION ExtractFirstExtended (S : string) : extended;
  654. { Returns first number in string, or zero on failure. }
  655.  
  656. VAR
  657.   Len  : byte absolute S;
  658.   Loop : byte;
  659.   N    : float;
  660.  
  661. BEGIN
  662.   ExtractFirstExtended := 0;
  663.   If not ContainsNumber (S) then exit;
  664.  
  665.   Loop := 0;
  666.   repeat                                         { look for start of word }
  667.     inc (Loop)
  668.   until
  669.     (Loop > Len)
  670.       or
  671.     InDecNumbers (S [Loop])
  672.       or
  673.     (S [Loop] = '-');
  674.   delete (S, 1, pred (Loop));
  675.  
  676.   Loop := 0;
  677.   repeat                                         { look for end of word }
  678.     inc (Loop)
  679.   until
  680.     (Loop > Len)
  681.       or
  682.     not InDecNumbers (S [Loop]);
  683.   dec (Loop);
  684.  
  685.   if Loop > 0 then
  686.     if Str2Real (GetSubStr (S, 1, Loop), N) then begin
  687.       ExtractFirstExtended := N;
  688.       delete (S, 1, Loop);
  689.       end;
  690. END;
  691.  
  692. { ========================================================================= }
  693. { Justify ================================================================= }
  694.  
  695. FUNCTION Justify (S : string80;  W : byte) : string80;
  696. {
  697.   Returns a string padded internally to length W.  Function assumes
  698.   that trailing spaces have been trimmed from string S.  Allows for
  699.   a five-space paragraph indentation at the beginning of a line.
  700.  
  701.   Justify counts through a string, adding spaces as equally as it can,
  702.   either from left to right or right to left depending on the status
  703.   of the (boolean) FlipFlag.  The purpose of the FlipFlag is to prevent
  704.   an uneven clumping of spaces on either the left or the right side of
  705.   the column.
  706.  
  707.   The formula for adding spaces is just a simple division of how many
  708.   spaces we have to add (over how many we've already added) compared to
  709.   how many spaces to add them to (over how many spaces we've already
  710.   passed).  It's a little tricky to explain, but it works very well.
  711. }
  712.  
  713. VAR
  714.   Len : byte absolute S;                         { length of S }
  715.   Loop,
  716.   StartPos,                                      { where to start }
  717.   SpacesInS,                                     { how many spaces in S }
  718.   SpaceCtr,                                      { for counting the spaces }
  719.   InsertCtr,                                     { how many spaces added }
  720.   AddHowMany : byte;                             { how many spaces to add }
  721.  
  722. CONST
  723.   FlipFlag : boolean = true;
  724.  
  725. BEGIN
  726.   While Len < W do begin
  727.     StartPos :=                                  { start count at what pos }
  728.       succ (5 * ord (Pos ('     ', S) = 1));     { allow for new paragraph }
  729.     SpacesInS := 0;                              { zero out counter }
  730.     For Loop := StartPos to Len do               { loop through string }
  731.       if S [Loop] = ' ' then
  732.         inc (SpacesInS);                         { count spaces in S }
  733.     AddHowMany := W - Len;                       { add how many spaces? }
  734.     InsertCtr := 0;                              { how many inserted? }
  735.     SpaceCtr := 0;                               { how many checked? }
  736.     if FlipFlag then begin                       { left to right? }
  737.       Loop := StartPos;
  738.       Repeat
  739.         inc (Loop);                              { step through S }
  740.         if S [Loop] = ' ' then begin             { if space ... }
  741.           if                                     { compute the spread }
  742.             (InsertCtr/AddHowMany <= SpaceCtr/SpacesInS)
  743.           then begin
  744.             Insert (' ', S, Loop);               { add space }
  745.             inc (InsertCtr);                     { count it }
  746.             inc (Loop);
  747.             end;
  748.           inc (SpaceCtr);                        { count spaces in S }
  749.           end;
  750.       Until                                      { until ... }
  751.         SpaceCtr/SpacesInS = 1;                  { we run out of spaces }
  752.       end
  753.     else begin                                   { right to left }
  754.       Loop := W;
  755.       Repeat
  756.         dec (Loop);                              { step backward through S }
  757.         if S [Loop] = ' ' then begin
  758.           if
  759.             (InsertCtr/AddHowMany <= SpaceCtr/SpacesInS)
  760.           then begin
  761.             Insert (' ', S, succ (Loop));        { add space }
  762.             inc (InsertCtr);                     { count it }
  763.             end;
  764.           Inc (SpaceCtr);                        { count spaces }
  765.           end;
  766.       Until                                      { until ... }
  767.         Loop = StartPos;                         { we get to the beginning }
  768.       end;
  769.     FlipFlag := not FlipFlag;                    { next time, go other way }
  770.     end;
  771.   Justify:= S;                                  { return to calling proc }
  772. END;
  773.  
  774. { ========================================================================= }
  775. { MultiSoundex ============================================================ }
  776.  
  777. FUNCTION MultiSoundex (S : string) : string;
  778. { Returns multiple soundex string for multiple words. }
  779.  
  780. VAR
  781.   Temp : StringPtr;
  782.  
  783. BEGIN
  784.   New (Temp);                                    { get memory }
  785.   Temp^ := '';
  786.   Repeat
  787.     Temp^ := Temp^ + Soundex (ExtractFirstWord (S));
  788.   Until
  789.     S = '';
  790.   MultiSoundex := Temp^;
  791.   Dispose (Temp);
  792. END;
  793.  
  794. { Compress ================================================================ }
  795.  
  796. FUNCTION Compress (S : string) : string;
  797. {
  798.   Takes S and compresses it at a ratio of 8:5.  Compression works by
  799.   converting 8-bit ASCII chararcters into 5-bit code.  Only letters
  800.   are unique.  Numbers and punctuation are ignored.  Based on routines
  801.   from Scott Bussinger.  See PC-Techniques, Vol 1.1.
  802. }
  803.  
  804. VAR
  805.   Len         : byte absolute S;
  806.   I           : word;
  807.   J           : word;
  808.   BitMask     : word;
  809.   ShiftFactor : word;
  810.   ResultStr   : string;
  811.  
  812. BEGIN
  813.   FillChar (ResultStr, sizeof (ResultStr), 0);   { Initialize result }
  814.   J := 1;
  815.   for I := 1 to Len do begin                     { Pack each char in turn }
  816.     ShiftFactor := (I + I + I) and 7;
  817.     case S [I] of
  818.       '0'..'9'  : BitMask := 27;
  819.       'a'..'z',
  820.       'A'..'Z'  : BitMask := ord (S [I]) and $1F;
  821.     else
  822.       BitMask := 0
  823.       end;  { case }
  824.     BitMask := BitMask shl ShiftFactor;
  825.     ResultStr [J] := chr (ord (ResultStr [J]) or lo (BitMask));
  826.     ResultStr [pred (J)] := chr (ord (ResultStr [pred (J)]) or hi (BitMask));
  827.     if ShiftFactor < 5 then
  828.       inc (J)
  829.     end;
  830.   ResultStr [0] := chr ((5 * Len + 7) shr 3);    { Set new length }
  831.   Compress := ResultStr
  832. END;
  833.  
  834. { Decompress ============================================================== }
  835.  
  836. FUNCTION Decompress (S : string) : string;
  837. {
  838.   Takes compressed string S and decompresses it at a ratio of 5:8.
  839.   All letters are capitalized.  Numbers and punctuation are blanked.
  840.   Based on routines from Scott Bussinger.
  841. }
  842.  
  843. TYPE
  844.   WordPtr = ^word;
  845.  
  846. VAR
  847.   Len         : byte absolute S;
  848.   I           : word;
  849.   J           : word;
  850.   ResultStr   : string;
  851.   ShiftFactor : word;
  852.  
  853. BEGIN
  854.   ResultStr [0] := chr ((8 * Len + 4) div 5);
  855.   FillChar (S [succ (Len)], 255 - Len, 0);
  856.     { In case we have a partially used last byte }
  857.   J := 0;
  858.   for I := 1 to length (ResultStr) do begin      { Get each char in turn }
  859.     ShiftFactor := (I + I + I) and 7;
  860.     ResultStr [I] := chr ((swap (WordPtr (@S [J])^) shr ShiftFactor)
  861.                           and $1F or $40);
  862.     case ResultStr [I] of
  863.       'A'..'Z': ;
  864.     else
  865.       ResultStr[I] := ' ';                       { Blank out odd chars }
  866.       end;
  867.     if ShiftFactor < 5 then
  868.       inc (J);
  869.     end;
  870.   Decompress := Trim (ResultStr);
  871. END;
  872.  
  873. { HashVal ================================================================= }
  874.  
  875. FUNCTION HashVal (S : String) : extended;
  876. { Returns a hash value based on the first 10 characters of the string. }
  877.  
  878. VAR
  879.   Count : extended;
  880.   Loop  : byte;
  881.   Len   : byte absolute S;
  882.  
  883. BEGIN
  884.   S := Pad (S, 10);
  885.   Count := 0;
  886.   For Loop := Len downto 1 do
  887.     if
  888.       (S [Loop] >= 'A') and (S [Loop] <= 'z')
  889.     then
  890.       Count := ord (UpCaseMac (S [Loop])) - 33 + Count/17;
  891.   HashVal := abs (Count * 0.033 - 1) ;
  892. End;
  893.  
  894. { ========================================================================= }
  895. { ========================================================================= }
  896.  
  897. { no initialization needed }
  898. END.
  899.  
  900. { ========================================================================= }
  901. { ========================================================================= }
  902.  
  903. VERSION HISTORY:
  904.   9005.05
  905.     Completely restructured for consistency with Object Professional.
  906.  
  907. { ========================================================================= }
  908.  
  909. NOTES:
  910.  
  911. { ========================================================================= }
  912.